home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / guile-ii.src / guile-ii / guile-src / slib / test.scm < prev    next >
Encoding:
Text File  |  1994-05-23  |  1.6 KB  |  58 lines
  1. ;;;; "test.scm", routines for testing.
  2. ;Copyright (C) 1991 Aubrey Jaffer
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. (define cur-section '())
  21.  
  22. (define errs '())
  23.  
  24. (define SECTION (lambda args
  25.           (display "SECTION") (write args) (newline)
  26.           (set! cur-section args) #t))
  27.  
  28. (define record-error
  29.   (lambda (e) (set! errs (cons (list cur-section e) errs))))
  30.  
  31. (define test
  32.   (lambda (expect fun . args)
  33.     (write (cons fun args))
  34.     (display "  ==> ")
  35.     ((lambda (res)
  36.       (write res)
  37.       (newline)
  38.       (cond ((not (equal? expect res))
  39.          (record-error (list res expect (cons fun args)))
  40.          (display " BUT EXPECTED ")
  41.          (write expect)
  42.          (newline)
  43.          #f)
  44.         (else #t)))
  45.      (if (procedure? fun) (apply fun args) (car args)))))
  46.  
  47. (define (report-errs)
  48.   (newline)
  49.   (if (null? errs) (display "Passed all tests")
  50.       (begin
  51.     (display "errors were:")
  52.     (newline)
  53.     (display "(SECTION (got expected (call)))")
  54.     (newline)
  55.     (for-each (lambda (l) (write l) (newline))
  56.           errs)))
  57.   (newline))
  58.